home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr53
/
pctv4n_1.zip
/
DBWRAP.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-06-10
|
9KB
|
352 lines
unit dbwrap;
interface
uses EBAY60, Objects;
type
TEBAbstract = object
ID, Result : integer;
procedure Error;
end;
ErrorProcedure = procedure(ErrorCode: Integer);
PEBField = ^TEBField;
TEBField = object(TEBAbstract)
Name : NameStr;
Table : Integer;
ebType: Integer;
constructor Init(FieldName: Namestr; TableID: Integer);
function AsInteger: Longint;
function AsString : String;
procedure GetData(var Data); virtual;
procedure SetData(var Data); virtual;
procedure Store(Data: String);
end;
PEBView = ^TEBView;
TEBView = object(TEBAbstract)
Fields : PCollection;
Index : NDXArg;
constructor Init(db: integer; Tbl: NameStr;
FldLst: String; NDX: NameStr);
destructor Done; virtual;
procedure Add;
function Field(Name: NameStr): PEBField;
function KeyFromString(S:String; var Key:KeyStr):integer;
function Search(Item: String): Integer;
procedure Store(Data: String);
procedure Update;
end;
PEBDatabase = ^TEBDatabase;
TEBDatabase = object(TEBAbstract)
constructor Init(N: NameStr);
function View(Table: NameStr; Fields: String;
Index: NameStr): PEBView;
destructor Done; virtual;
end;
TEBEngine = object(TEBAbstract)
constructor Init;
function OpenDataBase(N: NameStr): PEBDatabase;
destructor Done; virtual;
end;
const
ErrConversion = -10000;
ErrUnimplemented = -10001;
parsechar : char = ',';
Messages : array[0..1] of string =
('Conversion error',
'Attempt to use unimplemented feature.');
var
DatabaseError: ErrorProcedure;
implementation
const MonthStr = ' JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';
{ Utilities }
procedure Error(Code: Integer);
begin
writeln('Error in database call:');
If Code = 0 then writeln('Emerald Bay Engine not loaded.')
else If Code < -10000 then
begin
writeln(Messages[Abs(Code)]);
dbExit;
end
else begin
writeln(ErrorMsg(Code));
dbExit; {Give engine chance to close tables.}
end;
Halt(1);
end;
function Parse(var S: String): string; {WARNING: removes Parsed data}
var B: byte; {from "S" parameter}
begin
B := pos(parsechar,S);
If B = 0 then B := length(S)+1;
Parse := copy(s,1,b-1);
Delete(s,1,B);
end;
function DateFromString(S: String): longint;
var code, day, month, year: integer;
begin
Val(copy(S,1,2), Day, Code);
Month := Pos(copy(s,3,3),MONTHSTR);
Val(Copy(S,5,4), Year, Code);
If (Day=0) or (Month=0) or (Year=0) then DateFromString := errConversion
else DateFromString := CalJul(Day, Month, Year);
end;
function IncidencesOf(C: Char; S: String): byte;
var I, J : byte;
begin
J := 0;
For I := 1 to Length(S) do if S[I] = C then Inc(J);
IncidencesOf := J;
end;
Function UpCaseString(S : string) : string;
var I : byte;
begin
for I := 1 to length(s) do s[i] := upcase(s[i]);
UpCaseString := s;
end;
{ Abstract }
procedure TEBAbstract.Error;
begin
DatabaseError(Result);
end;
{ Field Methods }
constructor TEBField.Init;
var FARG: FLDArg;
begin
Table := TableID;
Name := UpcaseString(FieldName);
Result := dbGetNamedFieldInfo(Table, Name, Farg);
If Result>=0 then
begin
ID := FArg.FldID;
ebType := Farg.FldType;
end
else Error;
end;
function TEBField.AsInteger: longInt;
var N: LongInt;
begin
case EBType of
dTypLng, dTypDat: begin {dates are stored as longints}
GetData(N);
AsInteger := N;
end;
else Result := errUnimplemented; {easily add string to integer}
end; {conversions by calling AsString}
If Result<0 then Error; {then using Pascal's VAL proc}
end;
function TEBField.AsString: string;
var D: array[1..2048] of char;
begin
GetData(D);
case ebType of
dTypStr: begin
MakeStr(D); {EB uses ASCIIZ strings}
AsString := String((@D)^); {this converts/typecast}
end;
else Result := errUnimplemented;
end;
end;
procedure TEBField.Store;
var Code : integer;
L : LongInt;
begin
case EBType of
dTypStr: begin
cnvstr(data);
SetData(Data);
end;
dTypLng: begin
Val(Data, L, Code);
If Code<>0 then Result := errConversion
else SetData(L);
end;
dTypDat: begin
L := DateFromString(string((@Data)^)); {accepts only one format}
If Result<>errConversion then SetData(L); {for dates ddmmmyyyy}
end;
else Result := errUnimplemented;
end;
If Result<0 then Error;
end;
procedure TEBField.GetData;
begin
Result := DBFetch(Table,ID,Data);
If Result<0 then Error;
end;
procedure TEBField.SetData;
begin
Result := dbStore(Table, ID, Data);
If Result<0 then Error;
end;
{ View methods }
constructor TEBView.Init(db: integer; Tbl: NameStr; FldLst: String; NDX:
NameStr);
var P: PEBField;
S: String;
N: Byte;
begin
Result := dbOpenTable(db, Tbl);
If Result >= 0 then
begin
ID := Result;
N := IncidencesOf(ParseChar, FldLst) + 1;
Fields := New(PCollection, Init(N, 0));
repeat
P := New(PEBFIeld, Init(S, ID));
Result := P^.Result;
Fields^.Insert(P);
until (FldLst='') or (Result<0);
end;
If Result>=0 then
begin
Result := dbGetNamedIndexInfo(ID, NDX, Index);
If Result < 0 then Error;
end;
end;
destructor TEBView.Done;
begin
If Fields<>nil then Dispose(Fields, Done);
end;
procedure TEBView.Add;
begin
Result := dbAdd(ID);
If Result<0 then Error;
end;
function TEBView.Field(Name: NameStr): PEBField;
var I: Integer;
begin
Field := Nil;
Name := UpcaseString(Name);
For I := 0 to Fields^.Count - 1
do if PEBField(Fields^.At(I))^.Name = Name
then Field := Fields^.At(I);
end;
function TEBView.KeyFromString(S: String; var Key: KeyStr): integer;
var Code, FID, Loop : Integer;
L : LongInt;
Pattern, T : String;
FArg : FldArg;
Long : array[0..MaxNDX] of LongInt; {MaxNDX is 5}
KR : KeyRec;
begin
Loop := 0;
Pattern := '';
repeat
T := Parse(S);
FID := Index.NDXAtr[Loop];
Result := dbGetFieldInfo(ID, FId, Farg);
If Result>=0 then
begin
case FArg.FldType of
dTypLng: begin
Val(T, Long[Loop], Code);
KR[Loop] := @Long[Loop];
If Code<>0 then Result := errConversion;
Pattern := Pattern + 'l';
end;
else Result := errUnimplemented;
end;
end;
Inc(Loop);
until(Result<0) or (S='') or (Index.NDXAtr[Loop]=0);
If Result<0 then Error
else KeyFromString := dbMakeSearchKey(Key, Pattern, KR);
end;
function TEBView.Search(Item: String): Integer;
var K: KeyStr;
L: Integer;
begin
L := KeyFromString(Item, K);
Result := dbSearch(ID, Index.NDXID, K, L, equal);
If Result<-1 then Error;
Search := Result;
end;
procedure TEBView.Store(Data: String);
var P : PEBFIeld;
S, T : String;
L : Integer;
begin
L := 0;
repeat
P := Fields^.At(L);
T := Parse(Data);
If P<>nil then P^.Store(T);
inc(L);
until (P^.Result<0) or (Result<0);
If Result >= 0 then Result := P^.Result;
If Result<0 then Error;
end;
procedure TEBView.Update;
begin
Result := dbUpdate(ID);
If Result<0 then Error;
end;
{ Database Methods }
constructor TEBDatabase.Init(N: NameStr);
begin
Result := dbLogin(N, '');
ID := Result;
If Result<0 then Error;
end;
function TEBDatabase.View(Table: NameStr; Fields: String; Index: NameStr):
PEBView;
var V: PEBView;
begin
View := New(PEBView, Init(ID, Table, Fields, Index));
end;
destructor TEBDatabase.Done;
begin
Result := dbLogOut(ID);
end;
{ Engine Methods }
constructor TEBEngine.Init;
begin
Result := DBInit('admin');
If Result<=0 then Error;
end;
function TEBEngine.OpenDataBase(N: NameStr): PEBDatabase;
var D: PEBDatabase;
begin
OpenDatabase := New(PEBDatabase, Init(N));
end;
destructor TEBEngine.Done;
begin
DBExit;
end;
end.